home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / ufact.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  5.1 KB  |  168 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module ufact)
  13.  
  14. (DECLARE-TOP (SPECIAL MODULUS COEF-TYPE))
  15.  
  16. (load-macsyma-macros ratmac rzmac)
  17.  
  18. ;; Dense Polynomial Representation
  19.  
  20. (DEFUN DPREP (P)
  21.        (DO ((N (CAR P))
  22.         (E (CAR P) (f1- E))
  23.         (L))
  24.        ((< E 0) (CONS N (NREVERSE L)))
  25.        (COND ((EQUAL E (CAR P))
  26.           (PUSH (CADR P) L)
  27.           (SETQ P (CDDR P)))
  28.          (T (PUSH 0 L)))))
  29.  
  30. (DEFUN DPDISREP (L)
  31.        (COND ((ZEROP (CAR L)) (CADR L))
  32.          ((DO ((L (NREVERSE (CDR L)) (CDR L))
  33.            (N 0 (f1+ N))
  34.            (LL))
  35.           ((NULL L) LL)
  36.           (OR (= (CAR L) 0)
  37.               (SETQ LL (CONS N (CONS (CAR L) LL))))))))
  38.  
  39. ;; not currently called
  40. ;;(DEFUN PGCDU* (P Q)
  41. ;;       (COND ((OR (PCOEFP P) (PCOEFP Q))  1)
  42. ;;         ((NULL MODULUS)
  43. ;;          (merror  "ILLEGAL CALL TO PGCDU"))
  44. ;;         ((> (CADR P) (CADR Q)) 
  45. ;;          (PSIMP (CAR P) (DPDISREP (DPGCD (DPREP (CDR P)) (DPREP (CDR Q))))))
  46. ;;         ((PSIMP (CAR P) (DPDISREP (DPGCD (DPREP (CDR Q)) (DPREP (CDR P))))))))
  47. ;;
  48. ;;(DEFUN PMODSQFRU (P)
  49. ;;       (DO ((DPL (DPSQFR (DPREP (CDR P))) (CDR DPL))
  50. ;;        (PL NIL (CONS (PSIMP (CAR P) (DPDISREP (CDAR DPL))) (CONS (CAAR DPL) PL))))
  51. ;;       ((NULL DPL) PL)))
  52.  
  53. (DEFUN DPGCD (P Q)
  54.        (IF (< (CAR P) (CAR Q)) (EXCH P Q))
  55.        (DO ((P (COPY-TOP-LEVEL P) Q)
  56.         (Q (COPY-TOP-LEVEL Q) (DPREMQUO P Q NIL)))
  57.        ((= (CAR Q) 0)
  58.         (IF (= (CADR Q) 0) P '(0 1)))))
  59.  
  60. (DEFUN DPDIF (P Q)
  61.        (COND ((> (CAR P) (CAR Q))
  62.           (DO ((I (CAR P) (f1- I))
  63.            (PL (CDR P) (CDR PL))
  64.            (L NIL (CONS (CAR PL) L)))
  65.           ((= I (CAR Q)) (DPDIF1 PL (CDR Q) L)) ))
  66.          ((< (CAR P) (CAR Q))
  67.           (DO ((I (CAR Q) (f1- I))
  68.            (QL (CDR Q) (CDR QL))
  69.            (L NIL (CONS (CMINUS (CAR QL)) L)))
  70.           ((= I (CAR P)) (DPDIF1 (CDR P) QL L))))
  71.          (T (DPDIF1 (CDR P) (CDR Q) NIL))))
  72.  
  73. (DEFUN DPDIF1 (P1 Q1 L)
  74.        (DO ((PL P1 (CDR PL))
  75.         (QL Q1 (CDR QL))
  76.         (LL L (CONS (CDIFFERENCE (CAR PL) (CAR QL)) LL)))
  77.        ((NULL PL) (DPSIMP (NREVERSE LL)))))
  78.  
  79. (DEFUN DPSIMP (PL) (SETQ PL (ufact-strip-zeroes PL))
  80.        (COND ((NULL PL) '(0 0))
  81.          (T (CONS (f1- (LENGTH PL)) PL))))
  82.  
  83. (DEFUN DPDERIV (P)
  84.        (COND ((= 0 (CAR P)) '(0 0))
  85.          (T (DO ((L (CDR P) (CDR L))
  86.              (I (CAR P) (f1- I))
  87.              (DP NIL (CONS (CTIMES I (CAR L)) DP)))
  88.             ((= I 0) (CONS (f1- (CAR P)) (NREVERSE DP)))))))
  89.  
  90. (DEFUN DPSQFR (Q)                    ;ASSUMES MOD > DEGREE
  91.        (DO ((C Q (DPMODQUO C P))
  92.         (D (DPDERIV Q) (DPMODQUO D P))
  93.         (I 0 (f1+ I))
  94.         (P)
  95.         (PL))
  96.        ((= 0 (CAR C)) PL)
  97.        (COND (P (SETQ D (DPDIF D (DPDERIV C))
  98.               P (DPGCD C D))
  99.             (AND (> (CAR P) 0)
  100.              (SETQ PL (CONS (CONS I P) PL))))
  101.          (T (SETQ P (DPGCD C D))
  102.             (COND ((= (CAR P) 0) (RETURN (NCONS (CONS 1 C)))))))))
  103.  
  104.  
  105.  
  106. (DEFUN DPMODREM (P Q)
  107.        (COND ((< (CAR P) (CAR Q)) P)
  108.          ((= (CAR Q) 0) '(0 0))
  109.          ((DPREMQUO (COPY1* P) (COPY1* Q) NIL))))
  110.   
  111. (DEFUN DPMODQUO (P Q)
  112.        (COND ((< (CAR P) (CAR Q)) '(0 0))
  113.          ((= (CAR Q) 0)
  114.           (COND ((EQUAL (CADR Q) 1) P)
  115.             (T (CONS (CAR P)
  116.                  (MAPCAR #'(LAMBDA (C) (CQUOTIENT C (CADR Q))) (CDR P))
  117.                  ))))
  118.          ((DPREMQUO (COPY1* P) (COPY1* Q) T))))
  119.   
  120. ;; If FLAG is T, return quotient.  Otherwise return remainder.
  121.  
  122. (DEFUN DPREMQUO (P Q FLAG)
  123.      (PROG (LP LQ L ALPHA)
  124.            (COND ((= (CADR Q) 1)
  125.               (SETQ ALPHA 1))
  126.              (T (SETQ ALPHA (CRECIP (CADR Q)))
  127.             (DO ((L (CDDR Q) (CDR L)))
  128.                 ((NULL L)
  129.                  (RPLACA (CDR Q) 1))
  130.                 (RPLACA L (CTIMES (CAR L) ALPHA)))))
  131.       A    (AND FLAG (SETQ L (CONS (CTIMES (CADR P) ALPHA) L)))
  132.            (SETQ LP (CDDR P) LQ (CDDR Q))
  133.       B    (RPLACA LP (CDIFFERENCE (CAR LP) (CTIMES (CAR LQ) (CADR P))))
  134.            (COND ((NULL (SETQ LQ (CDR LQ)))
  135.               (DO ((E (f1- (CAR P)) (f1- E))
  136.                (PP (CDDR P) (CDR PP)))
  137.               ((NULL PP) (SETQ P '(0 0)))
  138.               (COND ((SIGNP E (CAR PP))
  139.                  (AND FLAG (NOT (< E (CAR Q)))
  140.                       (SETQ L (CONS 0 L))))
  141.                 ((RETURN (SETQ P (CONS E PP))))))
  142.               (COND ((< (CAR P) (CAR Q))
  143.                  (RETURN (COND (FLAG (DPSIMP (NREVERSE L)));GET EXP?
  144.                        (P))))
  145.                 ((GO A))))
  146.              (T (SETQ LP (CDR LP))
  147.             (GO B)))))
  148.  
  149. (DEFUN ufact-strip-zeroes (L)
  150.        (DO ((L L (CDR L)))
  151.        ((NULL (CZEROP (CAR L))) L)))
  152.  
  153. (DEFUN CPRES1 (A B)
  154.     (PROG (RES (V 0) A3) (DECLARE (FIXNUM V))
  155.         (SETQ  A (DPREP A) B (DPREP B))
  156.         (SETQ RES 1)
  157.       AGAIN (SETQ A3 (DPMODREM A B))
  158.         (SETQ V (BOOLE BOOLE-XOR V (logand 1 (CAR A) (CAR B) )))
  159.         (SETQ RES (CTIMES RES (CEXPT (CADR B)
  160.                          (f- (CAR A) (CAR A3)))))
  161.         (COND ((= 0 (CAR A3))
  162.                (SETQ RES (CTIMES RES (CEXPT (CADR A3) (CAR B))))
  163.                (RETURN (COND ((ODDP V) (CMINUS RES))
  164.                      (T RES))) ))
  165.         (SETQ A B)
  166.         (SETQ B A3)
  167.         (GO AGAIN) ))
  168.